home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wgdb-42.lha / wgdb-4.2 / gdb / m2-exp.y < prev    next >
Text File  |  1992-09-11  |  29KB  |  1,227 lines
  1. /* YACC grammar for Modula-2 expressions, for GDB.
  2.    Copyright (C) 1986, 1989, 1990, 1991 Free Software Foundation, Inc.
  3.    Generated from expread.y (now c-exp.y) and contributed by the Department
  4.    of Computer Science at the State University of New York at Buffalo, 1991.
  5.  
  6. This file is part of GDB.
  7.  
  8. This program is free software; you can redistribute it and/or modify
  9. it under the terms of the GNU General Public License as published by
  10. the Free Software Foundation; either version 2 of the License, or
  11. (at your option) any later version.
  12.  
  13. This program is distributed in the hope that it will be useful,
  14. but WITHOUT ANY WARRANTY; without even the implied warranty of
  15. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16. GNU General Public License for more details.
  17.  
  18. You should have received a copy of the GNU General Public License
  19. along with this program; if not, write to the Free Software
  20. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  */
  21.  
  22. /* Parse a Modula-2 expression from text in a string,
  23.    and return the result as a  struct expression  pointer.
  24.    That structure contains arithmetic operations in reverse polish,
  25.    with constants represented by operations that are followed by special data.
  26.    See expression.h for the details of the format.
  27.    What is important here is that it can be built up sequentially
  28.    during the process of parsing; the lower levels of the tree always
  29.    come first in the result.  */
  30.    
  31. %{
  32. #include <stdio.h>
  33. #include <string.h>
  34. #include "defs.h"
  35. #include "param.h"
  36. #include "symtab.h"
  37. #include "frame.h"
  38. #include "expression.h"
  39. #include "language.h"
  40. #include "value.h"
  41. #include "parser-defs.h"
  42.  
  43. /* These MUST be included in any grammar file!!!!
  44.    Please choose unique names! */
  45. #define    yyparse    m2_parse
  46. #define    yylex    m2_lex
  47. #define    yyerror    m2_error
  48. #define    yylval    m2_lval
  49. #define    yychar    m2_char
  50. #define    yydebug    m2_debug
  51. #define    yypact    m2_pact
  52. #define    yyr1    m2_r1
  53. #define    yyr2    m2_r2
  54. #define    yydef    m2_def
  55. #define    yychk    m2_chk
  56. #define    yypgo    m2_pgo
  57. #define    yyact    m2_act
  58. #define    yyexca    m2_exca
  59. #define yyerrflag m2_errflag
  60. #define yynerrs    m2_nerrs
  61. #define    yyps    m2_ps
  62. #define    yypv    m2_pv
  63. #define    yys    m2_s
  64. #define    yystate    m2_state
  65. #define    yytmp    m2_tmp
  66. #define    yyv    m2_v
  67. #define    yyval    m2_val
  68. #define    yylloc    m2_lloc
  69.  
  70. /* Forward decl's */
  71. void yyerror ();
  72. static int yylex ();
  73. int yyparse ();
  74.  
  75. /* The sign of the number being parsed. */
  76. int number_sign = 1;
  77.  
  78. /* The block that the module specified by the qualifer on an identifer is
  79.    contained in, */
  80. struct block *modblock=0;
  81.  
  82. char *make_qualname();
  83.  
  84. /* #define    YYDEBUG    1 */
  85.  
  86. %}
  87.  
  88. /* Although the yacc "value" of an expression is not used,
  89.    since the result is stored in the structure being created,
  90.    other node types do have values.  */
  91.  
  92. %union
  93.   {
  94.     LONGEST lval;
  95.     unsigned LONGEST ulval;
  96.     double dval;
  97.     struct symbol *sym;
  98.     struct type *tval;
  99.     struct stoken sval;
  100.     int voidval;
  101.     struct block *bval;
  102.     enum exp_opcode opcode;
  103.     struct internalvar *ivar;
  104.  
  105.     struct type **tvec;
  106.     int *ivec;
  107.   }
  108.  
  109. %type <voidval> exp type_exp start set
  110. %type <voidval> variable
  111. %type <tval> type
  112. %type <bval> block 
  113. %type <sym> fblock 
  114.  
  115. %token <lval> INT HEX ERROR
  116. %token <ulval> UINT TRUE FALSE CHAR
  117. %token <dval> FLOAT
  118.  
  119. /* Both NAME and TYPENAME tokens represent symbols in the input,
  120.    and both convey their data as strings.
  121.    But a TYPENAME is a string that happens to be defined as a typedef
  122.    or builtin type name (such as int or char)
  123.    and a NAME is any other symbol.
  124.  
  125.    Contexts where this distinction is not important can use the
  126.    nonterminal "name", which matches either NAME or TYPENAME.  */
  127.  
  128. %token <sval> STRING
  129. %token <sval> NAME BLOCKNAME IDENT CONST VARNAME
  130. %token <sval> TYPENAME
  131.  
  132. %token SIZE CAP ORD HIGH ABS MIN MAX FLOAT_FUNC VAL CHR ODD TRUNC
  133. %token INC DEC INCL EXCL
  134.  
  135. /* The GDB scope operator */
  136. %token COLONCOLON
  137.  
  138. %token <lval> LAST REGNAME
  139.  
  140. %token <ivar> INTERNAL_VAR
  141.  
  142. /* M2 tokens */
  143. %left ','
  144. %left ABOVE_COMMA
  145. %nonassoc ASSIGN
  146. %left '<' '>' LEQ GEQ '=' NOTEQUAL '#' IN
  147. %left OR
  148. %left AND '&'
  149. %left '@'
  150. %left '+' '-'
  151. %left '*' '/' DIV MOD
  152. %right UNARY
  153. %right '^' DOT '[' '('
  154. %right NOT '~'
  155. %left COLONCOLON QID
  156. /* This is not an actual token ; it is used for precedence. 
  157. %right QID
  158. */
  159. %%
  160.  
  161. start   :    exp
  162.     |    type_exp
  163.     ;
  164.  
  165. type_exp:    type
  166.         { write_exp_elt_opcode(OP_TYPE);
  167.           write_exp_elt_type($1);
  168.           write_exp_elt_opcode(OP_TYPE);
  169.         }
  170.     ;
  171.  
  172. /* Expressions */
  173.  
  174. exp     :       exp '^'   %prec UNARY
  175.                         { write_exp_elt_opcode (UNOP_IND); }
  176.  
  177. exp    :    '-'
  178.             { number_sign = -1; }
  179.         exp    %prec UNARY
  180.             { number_sign = 1;
  181.               write_exp_elt_opcode (UNOP_NEG); }
  182.     ;
  183.  
  184. exp    :    '+' exp    %prec UNARY
  185.         { write_exp_elt_opcode(UNOP_PLUS); }
  186.     ;
  187.  
  188. exp    :    not_exp exp %prec UNARY
  189.             { write_exp_elt_opcode (UNOP_ZEROP); }
  190.     ;
  191.  
  192. not_exp    :    NOT
  193.     |    '~'
  194.     ;
  195.  
  196. exp    :    CAP '(' exp ')'
  197.             { write_exp_elt_opcode (UNOP_CAP); }
  198.     ;
  199.  
  200. exp    :    ORD '(' exp ')'
  201.             { write_exp_elt_opcode (UNOP_ORD); }
  202.     ;
  203.  
  204. exp    :    ABS '(' exp ')'
  205.             { write_exp_elt_opcode (UNOP_ABS); }
  206.     ;
  207.  
  208. exp    :     HIGH '(' exp ')'
  209.             { write_exp_elt_opcode (UNOP_HIGH); }
  210.     ;
  211.  
  212. exp     :    MIN '(' type ')'
  213.             { write_exp_elt_opcode (UNOP_MIN);
  214.               write_exp_elt_type ($3);
  215.               write_exp_elt_opcode (UNOP_MIN); }
  216.     ;
  217.  
  218. exp    :     MAX '(' type ')'
  219.             { write_exp_elt_opcode (UNOP_MAX);
  220.               write_exp_elt_type ($3);
  221.               write_exp_elt_opcode (UNOP_MIN); }
  222.     ;
  223.  
  224. exp    :    FLOAT_FUNC '(' exp ')'
  225.             { write_exp_elt_opcode (UNOP_FLOAT); }
  226.     ;
  227.  
  228. exp    :    VAL '(' type ',' exp ')'
  229.             { write_exp_elt_opcode (BINOP_VAL);
  230.               write_exp_elt_type ($3);
  231.               write_exp_elt_opcode (BINOP_VAL); }
  232.     ;
  233.  
  234. exp    :    CHR '(' exp ')'
  235.             { write_exp_elt_opcode (UNOP_CHR); }
  236.     ;
  237.  
  238. exp    :    ODD '(' exp ')'
  239.             { write_exp_elt_opcode (UNOP_ODD); }
  240.     ;
  241.  
  242. exp    :    TRUNC '(' exp ')'
  243.             { write_exp_elt_opcode (UNOP_TRUNC); }
  244.     ;
  245.  
  246. exp    :    SIZE exp       %prec UNARY
  247.             { write_exp_elt_opcode (UNOP_SIZEOF); }
  248.     ;
  249.  
  250.  
  251. exp    :    INC '(' exp ')'
  252.             { write_exp_elt_opcode(UNOP_PREINCREMENT); }
  253.     ;
  254.  
  255. exp    :    INC '(' exp ',' exp ')'
  256.             { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
  257.               write_exp_elt_opcode(BINOP_ADD);
  258.               write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
  259.     ;
  260.  
  261. exp    :    DEC '(' exp ')'
  262.             { write_exp_elt_opcode(UNOP_PREDECREMENT);}
  263.     ;
  264.  
  265. exp    :    DEC '(' exp ',' exp ')'
  266.             { write_exp_elt_opcode(BINOP_ASSIGN_MODIFY);
  267.               write_exp_elt_opcode(BINOP_SUB);
  268.               write_exp_elt_opcode(BINOP_ASSIGN_MODIFY); }
  269.     ;
  270.  
  271. exp    :    exp DOT NAME
  272.             { write_exp_elt_opcode (STRUCTOP_STRUCT);
  273.               write_exp_string ($3);
  274.               write_exp_elt_opcode (STRUCTOP_STRUCT); }
  275.     ;
  276.  
  277. exp    :    set
  278.     ;
  279.  
  280. exp    :    exp IN set
  281.             { error("Sets are not implemented.");}
  282.     ;
  283.  
  284. exp    :    INCL '(' exp ',' exp ')'
  285.             { error("Sets are not implemented.");}
  286.     ;
  287.  
  288. exp    :    EXCL '(' exp ',' exp ')'
  289.             { error("Sets are not implemented.");}
  290.  
  291. set    :    '{' arglist '}'
  292.             { error("Sets are not implemented.");}
  293.     |    type '{' arglist '}'
  294.             { error("Sets are not implemented.");}
  295.     ;
  296.  
  297.  
  298. /* Modula-2 array subscript notation [a,b,c...] */
  299. exp     :       exp '['
  300.                         /* This function just saves the number of arguments
  301.                that follow in the list.  It is *not* specific to
  302.                function types */
  303.                         { start_arglist(); }
  304.                 non_empty_arglist ']'  %prec DOT
  305.                         { write_exp_elt_opcode (BINOP_MULTI_SUBSCRIPT);
  306.               write_exp_elt_longcst ((LONGEST) end_arglist());
  307.               write_exp_elt_opcode (BINOP_MULTI_SUBSCRIPT); }
  308.         ;
  309.  
  310. exp    :    exp '('
  311.             /* This is to save the value of arglist_len
  312.                being accumulated by an outer function call.  */
  313.             { start_arglist (); }
  314.         arglist ')'    %prec DOT
  315.             { write_exp_elt_opcode (OP_FUNCALL);
  316.               write_exp_elt_longcst ((LONGEST) end_arglist ());
  317.               write_exp_elt_opcode (OP_FUNCALL); }
  318.     ;
  319.  
  320. arglist    :
  321.     ;
  322.  
  323. arglist    :    exp
  324.             { arglist_len = 1; }
  325.     ;
  326.  
  327. arglist    :    arglist ',' exp   %prec ABOVE_COMMA
  328.             { arglist_len++; }
  329.     ;
  330.  
  331. non_empty_arglist
  332.         :       exp
  333.                         { arglist_len = 1; }
  334.     ;
  335.  
  336. non_empty_arglist
  337.         :       non_empty_arglist ',' exp %prec ABOVE_COMMA
  338.                             { arglist_len++; }
  339.          ;
  340.  
  341. /* GDB construct */
  342. exp    :    '{' type '}' exp  %prec UNARY
  343.             { write_exp_elt_opcode (UNOP_MEMVAL);
  344.               write_exp_elt_type ($2);
  345.               write_exp_elt_opcode (UNOP_MEMVAL); }
  346.     ;
  347.  
  348. exp     :       type '(' exp ')' %prec UNARY
  349.                         { write_exp_elt_opcode (UNOP_CAST);
  350.               write_exp_elt_type ($1);
  351.               write_exp_elt_opcode (UNOP_CAST); }
  352.     ;
  353.  
  354. exp    :    '(' exp ')'
  355.             { }
  356.     ;
  357.  
  358. /* Binary operators in order of decreasing precedence.  Note that some
  359.    of these operators are overloaded!  (ie. sets) */
  360.  
  361. /* GDB construct */
  362. exp    :    exp '@' exp
  363.             { write_exp_elt_opcode (BINOP_REPEAT); }
  364.     ;
  365.  
  366. exp    :    exp '*' exp
  367.             { write_exp_elt_opcode (BINOP_MUL); }
  368.     ;
  369.  
  370. exp    :    exp '/' exp
  371.             { write_exp_elt_opcode (BINOP_DIV); }
  372.     ;
  373.  
  374. exp     :       exp DIV exp
  375.                         { write_exp_elt_opcode (BINOP_INTDIV); }
  376.         ;
  377.  
  378. exp    :    exp MOD exp
  379.             { write_exp_elt_opcode (BINOP_REM); }
  380.     ;
  381.  
  382. exp    :    exp '+' exp
  383.             { write_exp_elt_opcode (BINOP_ADD); }
  384.     ;
  385.  
  386. exp    :    exp '-' exp
  387.             { write_exp_elt_opcode (BINOP_SUB); }
  388.     ;
  389.  
  390. exp    :    exp '=' exp
  391.             { write_exp_elt_opcode (BINOP_EQUAL); }
  392.     ;
  393.  
  394. exp    :    exp NOTEQUAL exp
  395.             { write_exp_elt_opcode (BINOP_NOTEQUAL); }
  396.         |       exp '#' exp
  397.                         { write_exp_elt_opcode (BINOP_NOTEQUAL); }
  398.     ;
  399.  
  400. exp    :    exp LEQ exp
  401.             { write_exp_elt_opcode (BINOP_LEQ); }
  402.     ;
  403.  
  404. exp    :    exp GEQ exp
  405.             { write_exp_elt_opcode (BINOP_GEQ); }
  406.     ;
  407.  
  408. exp    :    exp '<' exp
  409.             { write_exp_elt_opcode (BINOP_LESS); }
  410.     ;
  411.  
  412. exp    :    exp '>' exp
  413.             { write_exp_elt_opcode (BINOP_GTR); }
  414.     ;
  415.  
  416. exp    :    exp AND exp
  417.             { write_exp_elt_opcode (BINOP_AND); }
  418.     ;
  419.  
  420. exp    :    exp '&'    exp
  421.             { write_exp_elt_opcode (BINOP_AND); }
  422.     ;
  423.  
  424. exp    :    exp OR exp
  425.             { write_exp_elt_opcode (BINOP_OR); }
  426.     ;
  427.  
  428. exp    :    exp ASSIGN exp
  429.             { write_exp_elt_opcode (BINOP_ASSIGN); }
  430.     ;
  431.  
  432.  
  433. /* Constants */
  434.  
  435. exp    :    TRUE
  436.             { write_exp_elt_opcode (OP_BOOL);
  437.               write_exp_elt_longcst ((LONGEST) $1);
  438.               write_exp_elt_opcode (OP_BOOL); }
  439.     ;
  440.  
  441. exp    :    FALSE
  442.             { write_exp_elt_opcode (OP_BOOL);
  443.               write_exp_elt_longcst ((LONGEST) $1);
  444.               write_exp_elt_opcode (OP_BOOL); }
  445.     ;
  446.  
  447. exp    :    INT
  448.             { write_exp_elt_opcode (OP_LONG);
  449.               write_exp_elt_type (builtin_type_m2_int);
  450.               write_exp_elt_longcst ((LONGEST) $1);
  451.               write_exp_elt_opcode (OP_LONG); }
  452.     ;
  453.  
  454. exp    :    UINT
  455.             {
  456.               write_exp_elt_opcode (OP_LONG);
  457.               write_exp_elt_type (builtin_type_m2_card);
  458.               write_exp_elt_longcst ((LONGEST) $1);
  459.               write_exp_elt_opcode (OP_LONG);
  460.             }
  461.     ;
  462.  
  463. exp    :    CHAR
  464.             { write_exp_elt_opcode (OP_LONG);
  465.               write_exp_elt_type (builtin_type_m2_char);
  466.               write_exp_elt_longcst ((LONGEST) $1);
  467.               write_exp_elt_opcode (OP_LONG); }
  468.     ;
  469.  
  470.  
  471. exp    :    FLOAT
  472.             { write_exp_elt_opcode (OP_DOUBLE);
  473.               write_exp_elt_type (builtin_type_m2_real);
  474.               write_exp_elt_dblcst ($1);
  475.               write_exp_elt_opcode (OP_DOUBLE); }
  476.     ;
  477.  
  478. exp    :    variable
  479.     ;
  480.  
  481. /* The GDB internal variable $$, et al. */
  482. exp    :    LAST
  483.             { write_exp_elt_opcode (OP_LAST);
  484.               write_exp_elt_longcst ((LONGEST) $1);
  485.               write_exp_elt_opcode (OP_LAST); }
  486.     ;
  487.  
  488. exp    :    REGNAME
  489.             { write_exp_elt_opcode (OP_REGISTER);
  490.               write_exp_elt_longcst ((LONGEST) $1);
  491.               write_exp_elt_opcode (OP_REGISTER); }
  492.     ;
  493.  
  494. exp    :    SIZE '(' type ')'    %prec UNARY
  495.             { write_exp_elt_opcode (OP_LONG);
  496.               write_exp_elt_type (builtin_type_int);
  497.               write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3));
  498.               write_exp_elt_opcode (OP_LONG); }
  499.     ;
  500.  
  501. exp    :    STRING
  502.             { write_exp_elt_opcode (OP_M2_STRING);
  503.               write_exp_string ($1);
  504.               write_exp_elt_opcode (OP_M2_STRING); }
  505.     ;
  506.  
  507. /* This will be used for extensions later.  Like adding modules. */
  508. block    :    fblock    
  509.             { $$ = SYMBOL_BLOCK_VALUE($1); }
  510.     ;
  511.  
  512. fblock    :    BLOCKNAME
  513.             { struct symbol *sym
  514.                 = lookup_symbol (copy_name ($1), expression_context_block,
  515.                          VAR_NAMESPACE, 0, NULL);
  516.               $$ = sym;}
  517.     ;
  518.                  
  519.  
  520. /* GDB scope operator */
  521. fblock    :    block COLONCOLON BLOCKNAME
  522.             { struct symbol *tem
  523.                 = lookup_symbol (copy_name ($3), $1,
  524.                          VAR_NAMESPACE, 0, NULL);
  525.               if (!tem || SYMBOL_CLASS (tem) != LOC_BLOCK)
  526.                 error ("No function \"%s\" in specified context.",
  527.                    copy_name ($3));
  528.               $$ = tem;
  529.             }
  530.     ;
  531.  
  532. /* Useful for assigning to PROCEDURE variables */
  533. variable:    fblock
  534.             { write_exp_elt_opcode(OP_VAR_VALUE);
  535.               write_exp_elt_sym ($1);
  536.               write_exp_elt_opcode (OP_VAR_VALUE); }
  537.     ;
  538.  
  539. /* GDB internal ($foo) variable */
  540. variable:    INTERNAL_VAR
  541.             { write_exp_elt_opcode (OP_INTERNALVAR);
  542.               write_exp_elt_intern ($1);
  543.               write_exp_elt_opcode (OP_INTERNALVAR); }
  544.     ;
  545.  
  546. /* GDB scope operator */
  547. variable:    block COLONCOLON NAME
  548.             { struct symbol *sym;
  549.               sym = lookup_symbol (copy_name ($3), $1,
  550.                            VAR_NAMESPACE, 0, NULL);
  551.               if (sym == 0)
  552.                 error ("No symbol \"%s\" in specified context.",
  553.                    copy_name ($3));
  554.  
  555.               write_exp_elt_opcode (OP_VAR_VALUE);
  556.               write_exp_elt_sym (sym);
  557.               write_exp_elt_opcode (OP_VAR_VALUE); }
  558.     ;
  559.  
  560. /* Base case for variables. */
  561. variable:    NAME
  562.             { struct symbol *sym;
  563.               int is_a_field_of_this;
  564.  
  565.                sym = lookup_symbol (copy_name ($1),
  566.                            expression_context_block,
  567.                            VAR_NAMESPACE,
  568.                            &is_a_field_of_this,
  569.                            NULL);
  570.               if (sym)
  571.                 {
  572.                   switch (sym->class)
  573.                 {
  574.                 case LOC_REGISTER:
  575.                 case LOC_ARG:
  576.                 case LOC_LOCAL:
  577.                   if (innermost_block == 0 ||
  578.                       contained_in (block_found,
  579.                             innermost_block))
  580.                     innermost_block = block_found;
  581.                 }
  582.                   write_exp_elt_opcode (OP_VAR_VALUE);
  583.                   write_exp_elt_sym (sym);
  584.                   write_exp_elt_opcode (OP_VAR_VALUE);
  585.                 }
  586.               else
  587.                 {
  588.                   register int i;
  589.                   register char *arg = copy_name ($1);
  590.  
  591.                   for (i = 0; i < misc_function_count; i++)
  592.                 if (!strcmp (misc_function_vector[i].name, arg))
  593.                   break;
  594.  
  595.                   if (i < misc_function_count)
  596.                 {
  597.                   enum misc_function_type mft =
  598.                     (enum misc_function_type)
  599.                       misc_function_vector[i].type;
  600.  
  601.                   write_exp_elt_opcode (OP_LONG);
  602.                   write_exp_elt_type (builtin_type_int);
  603.                   write_exp_elt_longcst ((LONGEST) misc_function_vector[i].address);
  604.                   write_exp_elt_opcode (OP_LONG);
  605.                   write_exp_elt_opcode (UNOP_MEMVAL);
  606.                   if (mft == mf_data || mft == mf_bss)
  607.                     write_exp_elt_type (builtin_type_int);
  608.                   else if (mft == mf_text)
  609.                     write_exp_elt_type (lookup_function_type (builtin_type_int));
  610.                   else
  611.                     write_exp_elt_type (builtin_type_char);
  612.                   write_exp_elt_opcode (UNOP_MEMVAL);
  613.                 }
  614.                   else if (symtab_list == 0
  615.                        && partial_symtab_list == 0)
  616.                 error ("No symbol table is loaded.  Use the \"symbol-file\" command.");
  617.                   else
  618.                 error ("No symbol \"%s\" in current context.",
  619.                        copy_name ($1));
  620.                 }
  621.             }
  622.     ;
  623.  
  624. type
  625.     :    TYPENAME
  626.             { $$ = lookup_typename (copy_name ($1),
  627.                         expression_context_block, 0); }
  628.  
  629.     ;
  630.  
  631. %%
  632.  
  633. #if 0  /* FIXME! */
  634. int
  635. overflow(a,b)
  636.    long a,b;
  637. {
  638.    return (MAX_OF_TYPE(builtin_type_m2_int) - b) < a;
  639. }
  640.  
  641. int
  642. uoverflow(a,b)
  643.    unsigned long a,b;
  644. {
  645.    return (MAX_OF_TYPE(builtin_type_m2_card) - b) < a;
  646. }
  647. #endif /* FIXME */
  648.  
  649. /* Take care of parsing a number (anything that starts with a digit).
  650.    Set yylval and return the token type; update lexptr.
  651.    LEN is the number of characters in it.  */
  652.  
  653. /*** Needs some error checking for the float case ***/
  654.  
  655. static int
  656. parse_number (olen)
  657.      int olen;
  658. {
  659.   register char *p = lexptr;
  660.   register LONGEST n = 0;
  661.   register LONGEST prevn = 0;
  662.   register int c,i,ischar=0;
  663.   register int base = input_radix;
  664.   register int len = olen;
  665.   int unsigned_p = number_sign == 1 ? 1 : 0;
  666.  
  667.   extern double atof ();
  668.  
  669.   if(p[len-1] == 'H')
  670.   {
  671.      base = 16;
  672.      len--;
  673.   }
  674.   else if(p[len-1] == 'C' || p[len-1] == 'B')
  675.   {
  676.      base = 8;
  677.      ischar = p[len-1] == 'C';
  678.      len--;
  679.   }
  680.  
  681.   /* Scan the number */
  682.   for (c = 0; c < len; c++)
  683.   {
  684.     if (p[c] == '.' && base == 10)
  685.       {
  686.     /* It's a float since it contains a point.  */
  687.     yylval.dval = atof (p);
  688.     lexptr += len;
  689.     return FLOAT;
  690.       }
  691.     if (p[c] == '.' && base != 10)
  692.        error("Floating point numbers must be base 10.");
  693.     if (base == 10 && (p[c] < '0' || p[c] > '9'))
  694.        error("Invalid digit \'%c\' in number.",p[c]);
  695.  }
  696.  
  697.   while (len-- > 0)
  698.     {
  699.       c = *p++;
  700.       n *= base;
  701.       if( base == 8 && (c == '8' || c == '9'))
  702.      error("Invalid digit \'%c\' in octal number.",c);
  703.       if (c >= '0' && c <= '9')
  704.     i = c - '0';
  705.       else
  706.     {
  707.       if (base == 16 && c >= 'A' && c <= 'F')
  708.         i = c - 'A' + 10;
  709.       else
  710.          return ERROR;
  711.     }
  712.       n+=i;
  713.       if(i >= base)
  714.      return ERROR;
  715.       if(!unsigned_p && number_sign == 1 && (prevn >= n))
  716.      unsigned_p=1;        /* Try something unsigned */
  717.       /* Don't do the range check if n==i and i==0, since that special
  718.      case will give an overflow error. */
  719.       if(RANGE_CHECK && n!=i && i)
  720.       {
  721.      if((unsigned_p && (unsigned)prevn >= (unsigned)n) ||
  722.         ((!unsigned_p && number_sign==-1) && -prevn <= -n))
  723.         range_error("Overflow on numeric constant.");
  724.       }
  725.      prevn=n;
  726.     }
  727.  
  728.   lexptr = p;
  729.   if(*p == 'B' || *p == 'C' || *p == 'H')
  730.      lexptr++;            /* Advance past B,C or H */
  731.  
  732.   if (ischar)
  733.   {
  734.      yylval.ulval = n;
  735.      return CHAR;
  736.   }
  737.   else if ( unsigned_p && number_sign == 1)
  738.   {
  739.      yylval.ulval = n;
  740.      return UINT;
  741.   }
  742.   else if((unsigned_p && (n<0))) {
  743.      range_error("Overflow on numeric constant -- number too large.");
  744.      /* But, this can return if range_check == range_warn.  */
  745.   }
  746.   yylval.lval = n;
  747.   return INT;
  748. }
  749.  
  750.  
  751. /* Some tokens */
  752.  
  753. static struct
  754. {
  755.    char name[2];
  756.    int token;
  757. } tokentab2[] =
  758. {
  759.     {"<>",    NOTEQUAL      },
  760.     {":=",    ASSIGN     },
  761.     {"<=",    LEQ     },
  762.     {">=",    GEQ     },
  763.     {"::",    COLONCOLON },
  764.  
  765. };
  766.  
  767. /* Some specific keywords */
  768.  
  769. struct keyword {
  770.    char keyw[10];
  771.    int token;
  772. };
  773.  
  774. static struct keyword keytab[] =
  775. {
  776.     {"OR" ,   OR     },
  777.     {"IN",    IN         },/* Note space after IN */
  778.     {"AND",   AND        },
  779.     {"ABS",   ABS     },
  780.     {"CHR",   CHR     },
  781.     {"DEC",   DEC     },
  782.     {"NOT",   NOT     },
  783.     {"DIV",   DIV         },
  784.     {"INC",   INC     },
  785.     {"MAX",   MAX     },
  786.     {"MIN",   MIN     },
  787.     {"MOD",   MOD     },
  788.     {"ODD",   ODD     },
  789.     {"CAP",   CAP     },
  790.     {"ORD",   ORD     },
  791.     {"VAL",   VAL     },
  792.     {"EXCL",  EXCL     },
  793.     {"HIGH",  HIGH       },
  794.     {"INCL",  INCL     },
  795.     {"SIZE",  SIZE       },
  796.     {"FLOAT", FLOAT_FUNC },
  797.     {"TRUNC", TRUNC     },
  798. };
  799.  
  800.  
  801. /* Read one token, getting characters through lexptr.  */
  802.  
  803. /* This is where we will check to make sure that the language and the operators used are
  804.    compatible  */
  805.  
  806. static int
  807. yylex ()
  808. {
  809.   register int c;
  810.   register int namelen;
  811.   register int i;
  812.   register char *tokstart;
  813.   register char quote;
  814.  
  815.  retry:
  816.  
  817.   tokstart = lexptr;
  818.  
  819.  
  820.   /* See if it is a special token of length 2 */
  821.   for( i = 0 ; i < sizeof tokentab2 / sizeof tokentab2[0] ; i++)
  822.      if(!strncmp(tokentab2[i].name, tokstart, 2))
  823.      {
  824.     lexptr += 2;
  825.     return tokentab2[i].token;
  826.      }
  827.  
  828.   switch (c = *tokstart)
  829.     {
  830.     case 0:
  831.       return 0;
  832.  
  833.     case ' ':
  834.     case '\t':
  835.     case '\n':
  836.       lexptr++;
  837.       goto retry;
  838.  
  839.     case '(':
  840.       paren_depth++;
  841.       lexptr++;
  842.       return c;
  843.  
  844.     case ')':
  845.       if (paren_depth == 0)
  846.     return 0;
  847.       paren_depth--;
  848.       lexptr++;
  849.       return c;
  850.  
  851.     case ',':
  852.       if (comma_terminates && paren_depth == 0)
  853.     return 0;
  854.       lexptr++;
  855.       return c;
  856.  
  857.     case '.':
  858.       /* Might be a floating point number.  */
  859.       if (lexptr[1] >= '0' && lexptr[1] <= '9')
  860.     break;            /* Falls into number code.  */
  861.       else
  862.       {
  863.      lexptr++;
  864.      return DOT;
  865.       }
  866.  
  867. /* These are character tokens that appear as-is in the YACC grammar */
  868.     case '+':
  869.     case '-':
  870.     case '*':
  871.     case '/':
  872.     case '^':
  873.     case '<':
  874.     case '>':
  875.     case '[':
  876.     case ']':
  877.     case '=':
  878.     case '{':
  879.     case '}':
  880.     case '#':
  881.     case '@':
  882.     case '~':
  883.     case '&':
  884.       lexptr++;
  885.       return c;
  886.  
  887.     case '\'' :
  888.     case '"':
  889.       quote = c;
  890.       for (namelen = 1; (c = tokstart[namelen]) != quote && c != '\0'; namelen++)
  891.     if (c == '\\')
  892.       {
  893.         c = tokstart[++namelen];
  894.         if (c >= '0' && c <= '9')
  895.           {
  896.         c = tokstart[++namelen];
  897.         if (c >= '0' && c <= '9')
  898.           c = tokstart[++namelen];
  899.           }
  900.       }
  901.       if(c != quote)
  902.      error("Unterminated string or character constant.");
  903.       yylval.sval.ptr = tokstart + 1;
  904.       yylval.sval.length = namelen - 1;
  905.       lexptr += namelen + 1;
  906.  
  907.       if(namelen == 2)      /* Single character */
  908.       {
  909.        yylval.ulval = tokstart[1];
  910.        return CHAR;
  911.       }
  912.       else
  913.      return STRING;
  914.     }
  915.  
  916.   /* Is it a number?  */
  917.   /* Note:  We have already dealt with the case of the token '.'.
  918.      See case '.' above.  */
  919.   if ((c >= '0' && c <= '9'))
  920.     {
  921.       /* It's a number.  */
  922.       int got_dot = 0, got_e = 0;
  923.       register char *p = tokstart;
  924.       int toktype;
  925.  
  926.       for (++p ;; ++p)
  927.     {
  928.       if (!got_e && (*p == 'e' || *p == 'E'))
  929.         got_dot = got_e = 1;
  930.       else if (!got_dot && *p == '.')
  931.         got_dot = 1;
  932.       else if (got_e && (p[-1] == 'e' || p[-1] == 'E')
  933.            && (*p == '-' || *p == '+'))
  934.         /* This is the sign of the exponent, not the end of the
  935.            number.  */
  936.         continue;
  937.       else if ((*p < '0' || *p > '9') &&
  938.            (*p < 'A' || *p > 'F') &&
  939.            (*p != 'H'))  /* Modula-2 hexadecimal number */
  940.         break;
  941.     }
  942.     toktype = parse_number (p - tokstart);
  943.         if (toktype == ERROR)
  944.       {
  945.         char *err_copy = (char *) alloca (p - tokstart + 1);
  946.  
  947.         bcopy (tokstart, err_copy, p - tokstart);
  948.         err_copy[p - tokstart] = 0;
  949.         error ("Invalid number \"%s\".", err_copy);
  950.       }
  951.     lexptr = p;
  952.     return toktype;
  953.     }
  954.  
  955.   if (!(c == '_' || c == '$'
  956.     || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')))
  957.     /* We must have come across a bad character (e.g. ';').  */
  958.     error ("Invalid character '%c' in expression.", c);
  959.  
  960.   /* It's a name.  See how long it is.  */
  961.   namelen = 0;
  962.   for (c = tokstart[namelen];
  963.        (c == '_' || c == '$' || (c >= '0' && c <= '9')
  964.     || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'));
  965.        c = tokstart[++namelen])
  966.     ;
  967.  
  968.   /* The token "if" terminates the expression and is NOT
  969.      removed from the input stream.  */
  970.   if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f')
  971.     {
  972.       return 0;
  973.     }
  974.  
  975.   lexptr += namelen;
  976.  
  977.   /* Handle the tokens $digits; also $ (short for $0) and $$ (short for $$1)
  978.      and $$digits (equivalent to $<-digits> if you could type that).
  979.      Make token type LAST, and put the number (the digits) in yylval.  */
  980.  
  981.   if (*tokstart == '$')
  982.     {
  983.       register int negate = 0;
  984.       c = 1;
  985.       /* Double dollar means negate the number and add -1 as well.
  986.      Thus $$ alone means -1.  */
  987.       if (namelen >= 2 && tokstart[1] == '$')
  988.     {
  989.       negate = 1;
  990.       c = 2;
  991.     }
  992.       if (c == namelen)
  993.     {
  994.       /* Just dollars (one or two) */
  995.       yylval.lval = - negate;
  996.       return LAST;
  997.     }
  998.       /* Is the rest of the token digits?  */
  999.       for (; c < namelen; c++)
  1000.     if (!(tokstart[c] >= '0' && tokstart[c] <= '9'))
  1001.       break;
  1002.       if (c == namelen)
  1003.     {
  1004.       yylval.lval = atoi (tokstart + 1 + negate);
  1005.       if (negate)
  1006.         yylval.lval = - yylval.lval;
  1007.       return LAST;
  1008.     }
  1009.     }
  1010.  
  1011.   /* Handle tokens that refer to machine registers:
  1012.      $ followed by a register name.  */
  1013.  
  1014.   if (*tokstart == '$') {
  1015.     for (c = 0; c < NUM_REGS; c++)
  1016.       if (namelen - 1 == strlen (reg_names[c])
  1017.       && !strncmp (tokstart + 1, reg_names[c], namelen - 1))
  1018.     {
  1019.       yylval.lval = c;
  1020.       return REGNAME;
  1021.     }
  1022.     for (c = 0; c < num_std_regs; c++)
  1023.      if (namelen - 1 == strlen (std_regs[c].name)
  1024.      && !strncmp (tokstart + 1, std_regs[c].name, namelen - 1))
  1025.        {
  1026.      yylval.lval = std_regs[c].regnum;
  1027.      return REGNAME;
  1028.        }
  1029.   }
  1030.  
  1031.  
  1032.   /*  Lookup special keywords */
  1033.   for(i = 0 ; i < sizeof(keytab) / sizeof(keytab[0]) ; i++)
  1034.      if(namelen == strlen(keytab[i].keyw) && !strncmp(tokstart,keytab[i].keyw,namelen))
  1035.        return keytab[i].token;
  1036.  
  1037.   yylval.sval.ptr = tokstart;
  1038.   yylval.sval.length = namelen;
  1039.  
  1040.   /* Any other names starting in $ are debugger internal variables.  */
  1041.  
  1042.   if (*tokstart == '$')
  1043.     {
  1044.       yylval.ivar = (struct internalvar *) lookup_internalvar (copy_name (yylval.sval) + 1);
  1045.       return INTERNAL_VAR;
  1046.     }
  1047.  
  1048.  
  1049.   /* Use token-type BLOCKNAME for symbols that happen to be defined as
  1050.      functions.  If this is not so, then ...
  1051.      Use token-type TYPENAME for symbols that happen to be defined
  1052.      currently as names of types; NAME for other symbols.
  1053.      The caller is not constrained to care about the distinction.  */
  1054.  {
  1055.  
  1056.  
  1057.     char *tmp = copy_name (yylval.sval);
  1058.     struct symbol *sym;
  1059.  
  1060.     if (lookup_partial_symtab (tmp))
  1061.       return BLOCKNAME;
  1062.     sym = lookup_symbol (tmp, expression_context_block,
  1063.              VAR_NAMESPACE, 0, NULL);
  1064.     if (sym && SYMBOL_CLASS (sym) == LOC_BLOCK)
  1065.       return BLOCKNAME;
  1066.     if (lookup_typename (copy_name (yylval.sval), expression_context_block, 1))
  1067.       return TYPENAME;
  1068.  
  1069.     if(sym)
  1070.     {
  1071.        switch(sym->class)
  1072.        {
  1073.        case LOC_STATIC:
  1074.        case LOC_REGISTER:
  1075.        case LOC_ARG:
  1076.        case LOC_REF_ARG:
  1077.        case LOC_REGPARM:
  1078.        case LOC_LOCAL:
  1079.        case LOC_LOCAL_ARG:
  1080.        case LOC_CONST:
  1081.        case LOC_CONST_BYTES:
  1082.       return NAME;
  1083.  
  1084.        case LOC_TYPEDEF:
  1085.       return TYPENAME;
  1086.  
  1087.        case LOC_BLOCK:
  1088.       return BLOCKNAME;
  1089.  
  1090.        case LOC_UNDEF:
  1091.       error("internal:  Undefined class in m2lex()");
  1092.  
  1093.        case LOC_LABEL:
  1094.       error("internal:  Unforseen case in m2lex()");
  1095.        }
  1096.     }
  1097.     else
  1098.     {
  1099.        /* Built-in BOOLEAN type.  This is sort of a hack. */
  1100.        if(!strncmp(tokstart,"TRUE",4))
  1101.        {
  1102.       yylval.ulval = 1;
  1103.       return TRUE;
  1104.        }
  1105.        else if(!strncmp(tokstart,"FALSE",5))
  1106.        {
  1107.       yylval.ulval = 0;
  1108.       return FALSE;
  1109.        }
  1110.     }
  1111.  
  1112.     /* Must be another type of name... */
  1113.     return NAME;
  1114.  }
  1115. }
  1116.  
  1117. char *
  1118. make_qualname(mod,ident)
  1119.    char *mod, *ident;
  1120. {
  1121.    char *new = xmalloc(strlen(mod)+strlen(ident)+2);
  1122.  
  1123.    strcpy(new,mod);
  1124.    strcat(new,".");
  1125.    strcat(new,ident);
  1126.    return new;
  1127. }
  1128.  
  1129.  
  1130. void
  1131. yyerror()
  1132. {
  1133.    printf("Parsing:  %s\n",lexptr);
  1134.    if (yychar < 256)
  1135.      error("Invalid syntax in expression near character '%c'.",yychar);
  1136.    else
  1137.      error("Invalid syntax in expression");
  1138. }
  1139.  
  1140. /* Table of operators and their precedences for printing expressions.  */
  1141.  
  1142. const static struct op_print m2_op_print_tab[] = {
  1143.     {"+",   BINOP_ADD, PREC_ADD, 0},
  1144.     {"+",   UNOP_PLUS, PREC_PREFIX, 0},
  1145.     {"-",   BINOP_SUB, PREC_ADD, 0},
  1146.     {"-",   UNOP_NEG, PREC_PREFIX, 0},
  1147.     {"*",   BINOP_MUL, PREC_MUL, 0},
  1148.     {"/",   BINOP_DIV, PREC_MUL, 0},
  1149.     {"DIV", BINOP_INTDIV, PREC_MUL, 0},
  1150.     {"MOD", BINOP_REM, PREC_MUL, 0},
  1151.     {":=",  BINOP_ASSIGN, PREC_ASSIGN, 1},
  1152.     {"OR",  BINOP_OR, PREC_OR, 0},
  1153.     {"AND", BINOP_AND, PREC_AND, 0},
  1154.     {"NOT", UNOP_ZEROP, PREC_PREFIX, 0},
  1155.     {"=",   BINOP_EQUAL, PREC_EQUAL, 0},
  1156.     {"<>",  BINOP_NOTEQUAL, PREC_EQUAL, 0},
  1157.     {"<=",  BINOP_LEQ, PREC_ORDER, 0},
  1158.     {">=",  BINOP_GEQ, PREC_ORDER, 0},
  1159.     {">",   BINOP_GTR, PREC_ORDER, 0},
  1160.     {"<",   BINOP_LESS, PREC_ORDER, 0},
  1161.     {"^",   UNOP_IND, PREC_PREFIX, 0},
  1162.     {"@",   BINOP_REPEAT, PREC_REPEAT, 0},
  1163. };
  1164.  
  1165. /* The built-in types of Modula-2.  */
  1166.  
  1167. struct type *builtin_type_m2_char;
  1168. struct type *builtin_type_m2_int;
  1169. struct type *builtin_type_m2_card;
  1170. struct type *builtin_type_m2_real;
  1171. struct type *builtin_type_m2_bool;
  1172.  
  1173. struct type ** const (m2_builtin_types[]) = 
  1174. {
  1175.   &builtin_type_m2_char,
  1176.   &builtin_type_m2_int,
  1177.   &builtin_type_m2_card,
  1178.   &builtin_type_m2_real,
  1179.   &builtin_type_m2_bool,
  1180.   0
  1181. };
  1182.  
  1183. const struct language_defn m2_language_defn = {
  1184.   "modula-2",
  1185.   language_m2,
  1186.   m2_builtin_types,
  1187.   range_check_on,
  1188.   type_check_on,
  1189.   m2_parse,            /* parser */
  1190.   m2_error,            /* parser error function */
  1191.   &builtin_type_m2_int,        /* longest signed   integral type */
  1192.   &builtin_type_m2_card,        /* longest unsigned integral type */
  1193.   &builtin_type_m2_real,        /* longest floating point type */
  1194.   "0%XH", "0%", "XH",        /* Hex   format string, prefix, suffix */
  1195.   "%oB",  "%",  "oB",        /* Octal format string, prefix, suffix */
  1196.   m2_op_print_tab,        /* expression operators for printing */
  1197.   LANG_MAGIC
  1198. };
  1199.  
  1200. /* Initialization for Modula-2 */
  1201.  
  1202. void
  1203. _initialize_m2_exp ()
  1204. {
  1205.   /* FIXME:  The code below assumes that the sizes of the basic data
  1206.      types are the same on the host and target machines!!!  */
  1207.  
  1208.   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
  1209.   builtin_type_m2_int =  init_type (TYPE_CODE_INT, sizeof(int), 0, "INTEGER");
  1210.   builtin_type_m2_card = init_type (TYPE_CODE_INT, sizeof(int), 1, "CARDINAL");
  1211.   builtin_type_m2_real = init_type (TYPE_CODE_FLT, sizeof(float), 0, "REAL");
  1212.   builtin_type_m2_char = init_type (TYPE_CODE_CHAR, sizeof(char), 1, "CHAR");
  1213.  
  1214.   builtin_type_m2_bool = init_type (TYPE_CODE_BOOL, sizeof(int), 1, "BOOLEAN");
  1215.   TYPE_NFIELDS(builtin_type_m2_bool) = 2;
  1216.   TYPE_FIELDS(builtin_type_m2_bool) = 
  1217.      (struct field *) malloc (sizeof (struct field) * 2);
  1218.   TYPE_FIELD_BITPOS(builtin_type_m2_bool,0) = 0;
  1219.   TYPE_FIELD_NAME(builtin_type_m2_bool,0) = (char *)malloc(6);
  1220.   strcpy(TYPE_FIELD_NAME(builtin_type_m2_bool,0),"FALSE");
  1221.   TYPE_FIELD_BITPOS(builtin_type_m2_bool,1) = 1;
  1222.   TYPE_FIELD_NAME(builtin_type_m2_bool,1) = (char *)malloc(5);
  1223.   strcpy(TYPE_FIELD_NAME(builtin_type_m2_bool,1),"TRUE");
  1224.  
  1225.   add_language (&m2_language_defn);
  1226. }
  1227.